home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / amiga / c_src2_5.zoo / main.c < prev    next >
Encoding:
C/C++ Source or Header  |  1989-08-16  |  31.7 KB  |  1,404 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona, 1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24.  
  25. /* main.c */
  26.  
  27. #include "simdef.h"
  28. #include "aux.h"
  29. #include "inst.h"
  30.  
  31. #define system_up 1
  32.  
  33. #define pad lpcreg++
  34. #define opregno (*lpcreg++)
  35. #define regc(regno) (follow(rreg+regno))
  36. #define opregc (regc(opregno))
  37. #define opreg ((word)(rreg+opregno))
  38. #define opvarno (*lpcreg++)
  39. #define varc(varno) follow(le_reg+(-(long)varno))
  40. #define opvarc varc(opvarno)
  41. #define opvar ((word)(le_reg+(-(long)opvarno)))
  42.  
  43. #define opbyte *lpcreg++
  44. #define op2word op2 = *(pw)lpcreg; lpcreg+=4
  45. #define op3word op3 = *(pw)lpcreg; lpcreg+=4
  46. #define nparse_opPVRv pad; op1 = opvarc; op2 = opregc
  47. #define nparse_opPRRv pad; op1 = opregc; op2 = opregc
  48. #define nparse_opVWv op1 = opvarc; op2word
  49. #define nparse_opRWv op1 = opregc; op2word
  50. #define nparse_opRv op1 = opregc
  51. #define nparse_opVv op1 = opvarc
  52. #define nparse_opPW pad; op2word /* note op2! */
  53. #define nparse_opBW op1 = opbyte; op2word
  54. #define nparse_opB op1 = opbyte
  55.  
  56. extern byte *set_intercode();
  57. extern double floatval();
  58. extern word makefloat();
  59. extern prettymuch_equal();
  60. extern eval();
  61.  
  62. int floatp, temp_res;
  63. double result;
  64.  
  65. int current_opcode;
  66.  
  67. main(argc, argv)
  68. int argc;
  69. char *argv[];
  70.  
  71. { /* start main */
  72. struct psc_rec *psc;
  73.  
  74. #ifndef AMIGA
  75. pw opr;
  76. #endif
  77.  
  78. register byte *lpcreg;
  79. register word *le_reg;
  80. register word *rreg; /* for SUN */
  81. register word *sreg;
  82.  
  83. /* */
  84. register pw top;
  85. register word op1, op2;
  86. word op3;
  87. word top1, top2;
  88. int duymXX_=1;
  89.  
  90. short int i, arity;  /* to unify subfields of op1 and op2 */
  91.  
  92.    arm_intercept();
  93.    init_sim(argc, argv);
  94.    init_jump_table();
  95.    init_parse_routine();
  96.    init_load_routine();
  97.    init_builtin();
  98.    init_loading(argc, argv);
  99.    if (disassem) {
  100.     dis( );
  101.     printf("The byte code file is dumped in the file dump.pil\n");
  102.     exit(0);
  103.    }
  104.    lpcreg = inst_begin;
  105.    le_reg = (pw)ereg;
  106.    rreg = (pw)®[0]; /* for SUN */
  107.  
  108.    while ( system_up ) {        /* the main loop */
  109.  
  110. /* doesn't do anything (rnk at u of az, 8/89 */
  111. /*
  112.     if(0>1)
  113.         sreg = NULL;
  114. */
  115. contcase:
  116. /*   printf("%d\t\tInst: %x\n",duymXX_++,(*lpcreg&(0x00ff)));    */
  117.     switch ( *lpcreg++ ) {
  118.  
  119.  case getpvar00:  /* PVR */
  120.     pad;
  121.     op1 = opvarno;
  122.     varc(op1) = opregc;
  123.     goto contcase;
  124.  
  125.  case getpval00: /* PVR */
  126.     nparse_opPVRv;
  127.     goto nunify;
  128.  
  129.  case getstrv00: /* VW */
  130.     nparse_opVWv;
  131.     goto nunify_with_str;
  132.  
  133.  case gettval00: /* PRR */
  134.     nparse_opPRRv;
  135.     goto nunify;
  136.  
  137.  case getcon00: /* RW */
  138.     nparse_opRWv;
  139.     goto nunify_with_con;
  140.  
  141.  case getnil00: /* R */
  142.     nparse_opRv;
  143.     goto nunify_with_nil;
  144.  
  145.  case getstr00: /* RW */
  146.     nparse_opRWv;
  147.     goto nunify_with_str;
  148.  
  149.  case getlist00: /* R */
  150.     nparse_opRv;
  151.     goto nunify_with_list_sym;
  152.  
  153.  case getlist_k: /* R */
  154.     pad;
  155.     flag = READFLAG;
  156.     goto contcase;
  157.  
  158.  case unipvar00: /* V */
  159.     if (flag == WRITEFLAG) {
  160.     opvarc = (word)hreg;
  161.     new_heap_free;
  162.     }
  163.     else {
  164.  
  165.     opvarc = *sreg;
  166.     *sreg++;
  167.     }
  168.     goto contcase;
  169.  
  170.  case unipval00: /* V */
  171.     nparse_opVv;
  172.     if ( flag == WRITEFLAG ) goto nbldval;
  173.     else {  op2 = *sreg++;
  174.         goto nunify;
  175.      } 
  176.  
  177.  case unitvar00: /* R */
  178.     if ( flag == WRITEFLAG ) 
  179.     {opregc = (word)hreg;
  180.      new_heap_free;}
  181.     else opregc = *sreg++;
  182.     goto contcase;
  183.  
  184.  case unitval00: /* R */
  185.     nparse_opRv;
  186.     if ( flag == WRITEFLAG ) goto nbldval;
  187.     else 
  188.     { op2 = *sreg++;
  189.       goto nunify;
  190.     } 
  191.  
  192.  case unicon00: /* PW */
  193.     nparse_opPW; /* note goes to op2! */
  194.     if ( flag == WRITEFLAG ) new_heap_con(op2);
  195.     else {  /* op2 already set */
  196.         op1 = *sreg++;
  197.         goto nunify_with_con;}
  198.     goto contcase;
  199.  
  200.  case uninil00: /* P */
  201.     pad;
  202.     if ( flag == WRITEFLAG ) new_heap_node(nil_sym);
  203.     else {  op1 = *sreg++;
  204.         goto nunify_with_nil;}
  205.     goto contcase;
  206.  
  207.  case getnumcon: /* RW */
  208.     nparse_opRWv;
  209.     goto nunify_with_int;
  210.  
  211.  case getival: /* RW */
  212.     nparse_opRWv;
  213.     goto nunify;
  214.  
  215.  case test_unifiable: /* RRR */
  216.          /* if R1 and R2 are unifiable, then R3 is set to 1,
  217.             else R3 is set to 0.  Logically equivalent to
  218.             not(not(R1 = R2)).                   */
  219.     op1 = opregc;
  220.     op2 = opregc;
  221.     op3 = opreg;
  222.     top1 = (word)trreg;
  223.     follow(op3) = makeint(unify(op1, op2));
  224.     while ((word)trreg != top1) {  /* undo bindings, if any */
  225.     top = (pw)*(++trreg);
  226.     *(pw *)top = top;
  227.     };
  228.     goto contcase;
  229.  
  230.  case putnumcon: /* RW */
  231.  
  232.     op1 = opregno;
  233.     regc(op1) = makeint(*(pw)lpcreg); lpcreg+=4;
  234.     goto contcase;
  235.  
  236.  case putpvar00: /* PVR */
  237.     pad;
  238.     op1 = opvar;
  239.     follow(op1) = op1;
  240.     opregc = op1;
  241.     goto contcase;
  242.  
  243.  case putpval00: /* PVR */
  244.     pad;
  245.     op1 = opvarno;
  246.     opregc = varc(op1);
  247.     goto contcase;
  248.  
  249.  case puttvar00: /* PRR */
  250.     pad;
  251.     opregc = (word)hreg;
  252.     opregc = (word)hreg;
  253.     new_heap_free; 
  254.     goto contcase;
  255.  
  256.  case putstrv00: /*  VW */
  257.     opvarc = (word)hreg | CS_TAG;
  258.     new_heap_node(*(pw)lpcreg); lpcreg+=4;
  259.     goto contcase;
  260.  
  261.  case putcon00: /* RW */
  262.     op1 = opregno;
  263.     regc(op1) = (*(pw)lpcreg) | CS_TAG; lpcreg+=4;
  264.     goto contcase;
  265.  
  266.  case putnil00: /* R */
  267.     opregc = nil_sym;
  268.     goto contcase;
  269.  
  270.  case putstr00: /* RW */
  271.     opregc = (word)hreg | CS_TAG;
  272.     new_heap_node(*(pw)lpcreg); lpcreg+=4;
  273.     goto contcase;
  274.  
  275.  case putlist00: /* R */
  276.     opregc = (word)hreg | LIST_TAG;
  277.     goto contcase;
  278.  
  279.  case bldpvar00: /* V */
  280.     opvarc = (word)hreg;
  281.     new_heap_free;
  282.     goto contcase;
  283.  
  284.  case bldpval00: /* V */
  285.     nparse_opVv;
  286.     goto nbldval;
  287.  
  288.  case bldtvar00: /* R */
  289.     opregc = (word)hreg;
  290.     new_heap_free;
  291.     goto contcase;
  292.  
  293.  case bldtval00: /* R */
  294.     nparse_opRv;
  295.     goto nbldval;
  296.  
  297.  case bldcon00: /* PW */
  298.     pad;
  299.     new_heap_con(*(pw)lpcreg);
  300.     lpcreg+=4;
  301.     goto contcase;
  302.  
  303.  case bldnil00: /* P */
  304.     pad;
  305.     new_heap_node(nil_sym);
  306.     goto contcase;
  307.  
  308.  case getlist_tvar_tvar: /* BBB */
  309.     op1 = opregc;
  310.     glrr: switch ((int)(op1 & 3)) {
  311.     case FREE:
  312.         nderef(op1, glrr);
  313.         follow(op1) = (word)hreg | LIST_TAG;
  314.         pushtrail(op1);
  315.         opregc = (word)hreg;
  316.         new_heap_free;
  317.         opregc = (word)hreg;
  318.         new_heap_free;
  319.         break;
  320.     case CS:
  321.     case NUM:
  322.         Fail1;
  323.         break;
  324.     case LIST:
  325.         sreg = (pw)(untagged(op1));
  326.         opregc = *sreg++;
  327.         opregc = *sreg;
  328.         break;
  329.     }   /* end getlist_tvar_tvar */
  330.     goto contcase;
  331.  
  332.  case getlist_k_tvar_tvar: /* BBB */
  333.     pad;
  334. /*
  335.     sreg = (pw)(untagged(opregc));
  336. */
  337.     opregc = *sreg++;
  338.     opregc = *sreg;
  339.     goto contcase;
  340.  
  341.  case getcomma: /* R */
  342.     nparse_opRv;
  343.     op2 = (word)comma_psc;
  344.     goto nunify_with_str;
  345.  
  346.  case getcomma_tvar_tvar: /* BBB */
  347.     op1 = opregc;
  348.     gcrr: switch ((int) (op1 & 3)) {
  349.     case FREE:
  350.         nderef(op1, gcrr);
  351.         follow(op1) = (word)hreg | CS_TAG;
  352.         pushtrail(op1);
  353.         new_heap_node(((word)comma_psc));
  354.         pushtrail(op1);
  355.         opregc = (word)hreg;
  356.         new_heap_free;
  357.         opregc = (word)hreg;
  358.         new_heap_free;
  359.         break;
  360.     case CS:
  361.         untag(op1);
  362.         if (follow(op1) == (word)comma_psc) {
  363.         sreg = (pw)(op1+4);
  364.         opregc = *sreg++;
  365.         opregc = *sreg;
  366.         break;
  367.         }
  368.     case NUM:
  369.     case LIST:
  370.         Fail1;
  371.         break;
  372.     }   /* end getcomma_tvar_tvar */
  373.     goto contcase;
  374.  
  375.  case uninumcon: /* PL */
  376.     nparse_opPW; /* num in op2 */
  377.     if ( flag == WRITEFLAG ) new_heap_int(op2);
  378.     else {  /* op2 set */
  379.         op1 = *sreg++;
  380.         goto nunify_with_int;} 
  381.     goto contcase;
  382.  
  383.  case bldnumcon: /* PL */
  384.     nparse_opPW; /* num to op2 */
  385.     new_heap_int(op2);
  386.     goto contcase;
  387.  
  388.  case getfloatcon: /* RW */
  389.     nparse_opRWv;
  390.     goto nunify_with_float;
  391.  
  392.  case putfloatcon: /* RW */
  393.     op1 = opregno;
  394.     regc(op1) = (*(pw)lpcreg); lpcreg+=4;  /* float already tagged */
  395.     goto contcase;
  396.  
  397.  case unifloatcon: /* PL */
  398.     nparse_opPW; /* float in op2 */
  399.     if ( flag == WRITEFLAG ) new_heap_float(op2);
  400.     else {  /* op2 set */
  401.         op1 = *sreg++;
  402.         goto nunify_with_float;} 
  403.     goto contcase;
  404.  
  405.  case bldfloatcon: /* PL */
  406.     nparse_opPW; /* float to op2 */
  407.     new_heap_float(op2);
  408.     goto contcase;
  409.  
  410.  case trymeelse: /* BA */
  411.     nparse_opBW;
  412.     goto subtryme;
  413.  
  414.  case retrymeelse: /* BA */
  415.     op1 = *lpcreg++;
  416.     *(breg+1) = *(pw)lpcreg;
  417.     lpcreg+=4;
  418.     goto rerestore;
  419.  
  420.  case trustmeelsefail: /* B */
  421.     nparse_opB;
  422.     goto trrestore;
  423.  
  424.  case try: /* BA */
  425.     op1 = *lpcreg++;
  426.     op2 = (word)lpcreg + 4;
  427.     lpcreg = *(pb *)lpcreg;
  428.     goto subtryme;
  429.  
  430.  case retry: /* BA */
  431.     op1 = *lpcreg++;
  432.     *(breg+1) = (word)lpcreg+4;
  433.     lpcreg = *(pb *)lpcreg;
  434.     goto rerestore;
  435.  
  436.  case trust: /* BA */
  437.     op1 = *lpcreg++;
  438.     lpcreg = *(pb *)lpcreg;
  439.     goto trrestore;
  440.  
  441.  case getpbreg: /* V */
  442.     opvarc = (word)breg | NUM_TAG;
  443.     goto contcase;
  444.  
  445.  case gettbreg: /* R */
  446.     opregc = (word)breg | NUM_TAG;
  447.     goto contcase;
  448.  
  449.  case putpbreg: /* V */
  450.     nparse_opVv;
  451.     deref(op1);
  452.     breg = (pw)(untagged(op1));
  453.     hbreg = (pw)*(breg + 3);
  454.     goto contcase;
  455.  
  456.  case puttbreg: /* R */
  457.     nparse_opRv;
  458.     deref(op1);
  459.     breg = (pw)(untagged(op1));
  460.     hbreg = (pw)*(breg + 3);
  461.     goto contcase;
  462.  
  463.  case jumptbreg: /* RW */
  464.     opregc = (word)breg | NUM_TAG;
  465.     lpcreg = *(byte **)lpcreg;
  466.     goto contcase;
  467.  
  468.  case switchonterm: /* RWW */
  469.     op1 = opregc;
  470.     sotd: switch((int) (op1 & TAGMASK)) {
  471.     case FREE: nderef(op1, sotd);
  472.         lpcreg += 8; break;
  473.     case NUM:
  474.         lpcreg = *(pb *)lpcreg;        
  475.         break;
  476.     case CS:
  477.         if (get_str_arity(op1) == 0) {
  478.         lpcreg = *(pb *)lpcreg;
  479.         break;
  480.         }
  481.     case LIST:      /* include structure case here */
  482.         lpcreg += 4; lpcreg = *(pb *)lpcreg; 
  483.         break;
  484.     }
  485.     goto contcase;
  486.  
  487.  case switchonlist: /* RWW */
  488.     /* this is a specialization of the switchonterm instruction:
  489.            switchonlist R, L1, L2 means: if reg R derefs to '[]', goto
  490.        L1; if it derefs to [_|_], goto L2; if it derefs to a variable,
  491.        fall through; else fail. */
  492.     op1 = opregc;
  493.     sold: switch((int) (op1 & TAGMASK)) {
  494.     case FREE:
  495.         nderef(op1, sold);
  496.         lpcreg += 8; break;
  497.     case NUM:
  498.         Fail1; break;
  499.     case CS:
  500.         if (op1 == nil_sym) {
  501.         lpcreg = *(pb *)lpcreg;
  502.         }
  503.         else {Fail1;}
  504.         break;
  505.     case LIST:
  506.         sreg = (pw)(untagged(op1));
  507.         lpcreg += 4; lpcreg = *(pb *)lpcreg; 
  508.         break;
  509.     }
  510.     goto contcase;
  511.  
  512.  case switchonbound: /* RWW */
  513.     op1 = opregc;
  514.     sotd1: switch((int) (op1 & TAGMASK)) {
  515.     case FREE:  nderef(op1, sotd1); 
  516.         lpcreg += 8; goto sotd2;
  517.     case NUM: 
  518.         op1 = numval(op1);
  519.         break;
  520.     case LIST:
  521.         op1 = *((pw)untagged(list_str)); 
  522.         /* op1 = untagged(list_str); */
  523.         break;
  524.     case CS:
  525.         op1 = (word)get_str_psc(op1);
  526.             /* if (get_str_arity(op1) != 0) 
  527.                     op1 = (word)get_str_psc(op1);
  528.                 else op1 = untagged(op1); 
  529.                 op1 = untagged(op1); */
  530.             break;
  531.     }
  532.     op2 = *(pw)(lpcreg); lpcreg += 4;
  533.     op3 = *(pw)(lpcreg); 
  534.     lpcreg = *(pb *)(ihash(op1, op3) * 4 + op2);
  535.     sotd2: goto contcase;
  536.  
  537.  case arg:  /* RRR */
  538.     op1 = opregc;   /* index, i */
  539.     op2 = opregc;   /* term being indexed into, T */
  540.     op3 = opregc;   /* i_th. argument of T */
  541.     deref(op1);
  542.     if (!isinteger(op1)) {
  543.     printf("arg: Index must be an integer.\n");
  544.     Fail1; goto contcase;
  545.     }
  546.     op1 = intval(op1);
  547.     if (op1 <= 0) {printf("arg: index must be > 0\n"); Fail1; goto contcase;}
  548.     deref(op2);
  549.     if (isconstr(op2) && op1 <= get_str_arity(op2)) 
  550.     if (unify(*(((pw)(untag(op2))) + op1), op3)) goto contcase;
  551.     if (islist(op2) && op1 <= 2)
  552.     if (unify(*(((pw)(untag(op2))) + op1 - 1), op3)) goto contcase;
  553.     Fail1;
  554.     goto contcase; 
  555.  
  556.  case arg0:  /* RRR */
  557.     op1 = opregc;   /* index, i */
  558.     op2 = opregc;   /* term being indexed into, T */
  559.     op3 = opregc;   /* i_th. argument of T */
  560.     deref(op1);
  561.     if (!isinteger(op1)) {
  562.     printf("arg: Index must be an integer.\n");
  563.     Fail1; goto contcase;
  564.     }
  565.     op1 = intval(op1);
  566.     if (op1 <= 0)
  567.         {printf("arg: index must be > 0\n"); Fail1; goto contcase;}
  568.     deref(op2);
  569.     if (isconstr(op2) && op1 <= get_str_arity(op2)) 
  570.     op2 = *(((pw)(untag(op2))) + op1);
  571.     else if (islist(op2) && op1 <= 2)
  572.     op2 = *(((pw)(untag(op2))) + op1 - 1);
  573.     else {Fail1; goto contcase;}
  574.     deref(op3);
  575.     if (isnonvar(op2)) {
  576.     follow(op3) = op2;
  577.     pushtrail(op3);
  578.     }
  579.     else {    /* op2 is a variable */
  580.         if ( op2 != op3 ) {
  581.         if ( op2 < op3 ) {
  582.         if ( op2 < (word)hreg )  /* op2 not in loc stack */
  583.             {follow(op3) = op2; pushtrail(op3);}
  584.         else  /* op2 points to op3 */
  585.             {follow(op2) = op3; pushtrail(op2);}
  586.         }
  587.         else { /* op2 > op3 */
  588.         if ( op3 < (word)hreg ) 
  589.             {follow(op2) = op3; pushtrail(op2);}
  590.         else
  591.             {follow(op3) = op2; pushtrail(op3);}
  592.         }
  593.     }
  594.     }
  595.     goto contcase; 
  596.  
  597.  case get_tag: /* PRR */        /* derefs 1st operand reg, copies */
  598.     pad;            /* low 3 bits into 2nd operand reg */
  599.     op1 = opregc; deref(op1);
  600.     opregc = makeint((op1 & 0x7));
  601.     goto contcase;
  602.  
  603.  case movreg: /* PRR */
  604.     pad;
  605.     op1 = opregno;
  606.     opregc = regc(op1);
  607.     goto contcase;
  608.  
  609.  case addreg: /* PRR */
  610.     pad;
  611.     op1 = opregc;
  612.     op3 = opreg;
  613.     op2 = follow(op3);
  614.     deref(op1);
  615.     if (isinteger(op1)) floatp = 0;
  616.     else if (isfloat(op1)) floatp = 1;
  617.     else {floatp = eval(op1, &top1); op1 = top1;}
  618.     deref(op2);
  619.     if (isinteger(op2)) ;
  620.     else if (isfloat(op2)) floatp = floatp | 1;
  621.     else {floatp = floatp | eval(op2, &top2); op2 = top2;}
  622.     switch (floatp) {
  623.     case -1: printf("add: number required\n"); Fail1; break;
  624.     case  0: follow(op3) = op2 + (op1 - INT_TAG); break;
  625.     case  1: follow(op3) = makefloat(numval(op2) + numval(op1)); break;
  626.     };
  627.     goto contcase; 
  628.  
  629.  case subreg: /* PRR */
  630.     pad;
  631.     op1 = opregc;
  632.     op3 = opreg;
  633.     op2 = follow(op3);
  634.     deref(op1); 
  635.     if (isinteger(op1)) floatp = 0;
  636.     else if (isfloat(op1)) floatp = 1;
  637.     else {floatp = eval(op1, &top1); op1 = top1;}
  638.     deref(op2);
  639.     if (isinteger(op2)) ;
  640.     else if (isfloat(op2)) floatp = floatp | 1;
  641.     else {floatp = floatp | eval(op2, &top2); op2 = top2;}
  642.     switch (floatp) {
  643.     case -1: printf("sub: number required\n"); Fail1; break;
  644.     case  0: follow(op3) = op2 - (op1 - INT_TAG); break;
  645.     case  1: follow(op3) = makefloat(numval(op2) - numval(op1)); break;
  646.     };
  647.     goto contcase; 
  648.  
  649.  case mulreg: /* PRR */
  650.     pad;
  651.     op1 = opregc;
  652.     op3 = opreg;
  653.     op2 = follow(op3);
  654.     deref(op1); 
  655.     if (isinteger(op1)) floatp = 0;
  656.     else if (isfloat(op1)) floatp = 1;
  657.     else {floatp = eval(op1, &top1); op1 = top1;}
  658.     deref(op2);
  659.     if (isinteger(op2)) ;
  660.     else if (isfloat(op2)) floatp = floatp | 1;
  661.     else {floatp = floatp | eval(op2, &top2); op2 = top2;}
  662.     switch (floatp) {
  663.     case -1: printf("mul: number required\n"); Fail1; break;
  664.     case  0: temp_res = intval(op2) * intval(op1);
  665.          follow(op3) =
  666.             (int_overflo(temp_res) ? makefloat((double)temp_res) : makeint(temp_res));
  667.          break;
  668.     case  1: follow(op3) = makefloat(numval(op2) * numval(op1)); break;
  669.     };
  670.     goto contcase; 
  671.  
  672.  case divreg: /* PRR */
  673.     pad;
  674.     op1 = opregc;
  675.     op3 = opreg;
  676.     op2 = follow(op3);
  677.     deref(op1); 
  678.     if (isnum(op1)) floatp = 0;  /* cvt'ing op1, op2 to double soon anyway */
  679.     else {floatp = eval(op1, &top1); op1 = top1;}
  680.     deref(op2);
  681.     if (!isnum(op2)) {floatp = floatp | eval(op2, &top2); op2 = top2;}
  682.     result = ((double)(numval(op2)))/((double)(numval(op1)));
  683.     if (integral(result) && !int_overflo((int)result))
  684.         follow(op3) = makeint((int)result);
  685.     else follow(op3) = makefloat(result);
  686.     goto contcase; 
  687.  
  688.  case idivreg: /* PRR */
  689.     pad;
  690.     op1 = opregc;
  691.     op3 = opreg;
  692.     op2 = follow(op3);
  693.     deref(op1); 
  694.     if (isinteger(op1)) floatp = 0;
  695.     else {floatp = eval(op1, &top1); op1 = top1;}
  696.     deref(op2);
  697.     if (isinteger(op2)) ;
  698.     else {floatp = floatp | eval(op2, &top2); op2 = top2;}
  699.     if (floatp != 0)
  700.     {printf("integer division: operands must be integers\n");
  701.      Fail1;
  702.     }
  703.     else follow(op3) = makeint((int)((intval(op2))/(intval(op1))));
  704.     goto contcase; 
  705.  
  706.  case putdval00: /* PVR */
  707.  
  708.     pad;
  709.     op1 = opvarc;
  710.     deref(op1);
  711.     opregc = op1;
  712.     goto contcase;
  713.  
  714.  case putuval00: /* PVR */
  715.     pad;
  716.     op1 = opvarc;
  717.     deref(op1);
  718.     if (((op1 & TAGMASK) != 0) || (op1 < (word)hreg) || (op1 >= (word)le_reg))
  719.     opregc = op1;
  720.     else {follow(op1) = opregc = (word)hreg;
  721.     pushtrail(op1);
  722.     new_heap_free;
  723.     } 
  724.     goto contcase;
  725.  
  726.  case call: /* PW */
  727.  
  728.     nparse_opPW;
  729.     cpreg = lpcreg;
  730.     psc = (struct psc_rec *)op2;
  731.  
  732.     goto call_sub;
  733.  
  734.  case allocate: pad; 
  735.     if ((pw)breg < le_reg) op1 = (word)breg;
  736.     else op1 = (word)(le_reg - *(cpreg-5));
  737.     follow(op1) = (word)le_reg;
  738.     follow(op1-4) = (word)cpreg;
  739.     le_reg = (pw)op1; 
  740.     if (le_reg < hreg+100) if (!overflow_f) 
  741.         {overflow_f = 1; lpcreg = set_intercode(2); goto contcase;}
  742.  
  743.     goto contcase;
  744.  
  745.  case deallocate: pad; 
  746.     cpreg = (byte *)*(pw)(le_reg-1);
  747.     le_reg = *(pw *)le_reg;
  748.     goto contcase;
  749.  
  750.  case proceed: pad; 
  751.     lpcreg = cpreg;
  752.     goto contcase;
  753.  
  754.  case execute: 
  755.     nparse_opPW;
  756.     psc = (struct psc_rec *)op2;
  757.     goto call_sub;
  758.  
  759.  case unexec: /* PWW, builds str on heap, and executes 2nd arg 
  760.         simulates exec(op2(op1(A1,A2,..,An)) 
  761.         for intercepting calls */
  762.  
  763.     pad; op2word;
  764.  
  765.     op3 = (word)hreg;    /* save addr of new structure rec */
  766.  
  767.     new_heap_node(op2); /* set str psc ptr */
  768.  
  769.     for ( i=1; i<=get_arity((struct psc_rec *)op2); i++) {
  770.  
  771.     op1 = regc(i);
  772.     unebld: if ((op1 & 3) == 0) {
  773.  
  774.         nderef(op1, unebld);
  775.         follow(op1) = (word)hreg;
  776.         pushtrail(op1);
  777.         new_heap_free;
  778.         }
  779.     else new_heap_node(op1);
  780.     }
  781.  
  782.     regc(1) = op3 | CS_TAG; /* ptr to new structure on heap */
  783.  
  784.     op2word;
  785.  
  786.     psc = (struct psc_rec *)op2;
  787.  
  788.     goto call_sub;
  789.  
  790.  case unexeci: /* PWW, builds str on heap with last arg a var, 
  791.         and executes 2nd arg; for interpreting;
  792.         simulates exec(op2(op1(A1,A2,..,An-1,B),B) */
  793.     pad; op2word;
  794.     op3 = (word)hreg;    /* save addr of new structure rec */
  795.     new_heap_node(op2); /* set str psc ptr */
  796.     for ( i=1; i<get_arity((struct psc_rec *)op2); i++) {
  797.     op1 = regc(i);
  798.     unibld: if ((op1 & 3) == 0) {
  799.         nderef(op1, unibld);
  800.         follow(op1) = (word)hreg;
  801.         pushtrail(op1);
  802.         new_heap_free;
  803.         }
  804.     else new_heap_node(op1);
  805.     }
  806.     regc(1) = op3 | CS_TAG; /* ptr to new structure on heap */
  807.     regc(2) = (word)hreg;
  808.     new_heap_free; /* add last field to rec */
  809.     op2word;
  810.     psc = (struct psc_rec *)op2;
  811.     goto call_sub;
  812.  
  813.  case executev: 
  814.     nparse_opPW;
  815.     exun: switch ((int)(op2 & TAGMASK)) {
  816.     case FREE: nderef(op2,exun);
  817.     case NUM: printf("Error: Illegal call\n"); Fail1; goto contcase;
  818.     case CS: psc = get_str_psc(op2); goto call_sub;
  819.     case LIST: psc = list_psc; goto call_sub;
  820.     }
  821.  
  822. /*     pad; pcreg=lpcreg; 
  823.     callv_sub();
  824.     lpcreg=pcreg; break; */
  825.  
  826.  case jump: 
  827.     pad;
  828.     lpcreg = *(byte **)lpcreg;
  829.     goto contcase;
  830.  
  831.  case jumpz:
  832.     op3 = opregc;
  833.     if (numval(op3) == 0) lpcreg = *(byte **)lpcreg;
  834.     else lpcreg += 4;
  835.     goto contcase;
  836.  
  837.  case jumpnz: 
  838.     op3 = opregc;
  839.     if (numval(op3) != 0) lpcreg = *(byte **)lpcreg;
  840.     else lpcreg += 4;
  841.     goto contcase;
  842.  
  843.  case jumplt:
  844.     op3 = opregc;
  845.     if (numval(op3) < 0) lpcreg = *(byte **)lpcreg;
  846.     else lpcreg += 4;
  847.     goto contcase;
  848.  
  849.  case jumple:
  850.     op3 = opregc;
  851.     if (numval(op3) <= 0) lpcreg = *(byte **)lpcreg;
  852.     else lpcreg += 4;
  853.     goto contcase;
  854.  
  855.  case jumpgt:
  856.     op3 = opregc;
  857.     if (numval(op3) > 0) lpcreg = *(byte **)lpcreg;
  858.     else lpcreg += 4;
  859.     goto contcase;
  860.  
  861.  case jumpge:
  862.     op3 = opregc;
  863.     if (numval(op3) >= 0) lpcreg = *(byte **)lpcreg;
  864.     else lpcreg += 4;
  865.     goto contcase;
  866.  
  867.  case fail: pad;
  868.     Fail1; 
  869.     goto contcase;
  870.  
  871.  case noop: nparse_opB;
  872.     lpcreg += op1;
  873.     lpcreg += op1;
  874.     goto contcase;
  875.  
  876.  case halt: pad;
  877.     printf("\nHalt. Program terminated normally\n");
  878.     exit(0); 
  879.     goto contcase;
  880.  
  881.  case builtin: nparse_opB; pcreg=lpcreg; ereg = le_reg;
  882. /* printf("Builtin# %d\n", (byte)op1); */
  883.     Builtin((byte)op1);
  884.     lpcreg=pcreg; goto contcase;
  885.  
  886.  case calld: 
  887.     pad;
  888.     cpreg = lpcreg+4; 
  889.     lpcreg = *(pb *)lpcreg;
  890.     goto contcase;
  891.  
  892.  case lshiftr: 
  893.     pad;
  894.     op1 = opregc;
  895.     op3 = opreg;
  896.     op2 = follow(op3);
  897.     deref(op1); 
  898.     deref(op2);
  899.     if (!isinteger(op1) ||!isinteger(op2)) 
  900.     {printf("lshiftr: integer required\n"); Fail1;}
  901.     else follow(op3) = makeint((intval(op2)) >> intval(op1));
  902.     goto contcase; 
  903.  
  904.  case lshiftl: 
  905.     pad;
  906.     op1 = opregc;
  907.     op3 = opreg;
  908.     op2 = follow(op3);
  909.     deref(op1); 
  910.     deref(op2);
  911.     if (!isinteger(op1) || !isinteger(op2)) 
  912.     {printf("lshiftl: integer required\n"); Fail1;}
  913.     else follow(op3) = makeint((intval(op2)) << intval(op1));
  914.     goto contcase; 
  915.  
  916.  case or: 
  917.     pad;
  918.     op1 = opregc;
  919.     op3 = opreg;
  920.     op2 = follow(op3);
  921.     deref(op1); 
  922.     deref(op2);
  923.     if (!isinteger(op1) || !isinteger(op2)) 
  924.     {printf("or: integer required\n"); Fail1;}
  925.     else follow(op3) = makeint(intval(op2) | intval(op1));
  926.     goto contcase; 
  927.  
  928.  case and: 
  929.     pad;
  930.     op1 = opregc;
  931.     op3 = opreg;
  932.     op2 = follow(op3);
  933.     deref(op1); 
  934.     deref(op2);
  935.     if (!isinteger(op1) || !isinteger(op2)) 
  936.     {printf("and: integer required\n"); Fail1;}
  937.     else follow(op3) = makeint(intval(op2) & intval(op1));
  938.     goto contcase; 
  939.  
  940.  case negate: 
  941.     op1 = opregno;
  942.     op2 = regc(op1);
  943.     deref(op2);
  944.     if (!isinteger(op2)) 
  945.     {printf("negate: integer required\n"); Fail1;}
  946.     else regc(op1) = makeint(~intval(op2));
  947.     goto contcase; 
  948.  
  949.  case endfile: nparse_opPW; 
  950.     goto contcase;
  951.  
  952.  case getnil01 :
  953.  case getstr01 :
  954.  case getlist01 :
  955.  case unipvar01 :
  956.  case unipval01 :
  957.  case unitvar01 :
  958.  case unitval01 :
  959.  case unicon01 :
  960.  case uninil01 :
  961.  case putpvar01 :
  962.  case putpval01 :
  963.  case puttvar01 :
  964.  case putcon01 :
  965.  case putnil01 :
  966.  case putstr01 :
  967.  case putlist01 :
  968.  case bldpvar01 :
  969.  case bldpval01 :
  970.  case bldtvar01 :
  971.  case bldtval01 :
  972.  case bldcon01 :
  973.  case bldnil01 :
  974.  case getpvar10 :
  975.  case getpval10 :
  976.  case gettval10 :
  977.  case getcon10 :
  978.  case getnil10 :
  979.  case unicon10 :
  980.  case uninil10 :
  981.  case putpvar10 :
  982.  case putpval10 :
  983.  case puttvar10 :
  984.  case putcon10 :
  985.  case putnil10 :
  986.  case putstr10 :
  987.  case putlist10 :
  988.  case bldpvar10 :
  989.  case bldpval10 :
  990.  case bldtvar10 :
  991.  case bldtval10 :
  992.  case bldcon10 :
  993.  case bldnil10 :
  994.  case getpvar11 :
  995.  case getpval11 :
  996.  case gettval11 :
  997.  case getcon11 :
  998.  case getnil11 :
  999.  case getstr11 :
  1000.  case getlist11 :
  1001.  case unipvar11 :
  1002.  case unipval11 :
  1003.  case unitvar11 :
  1004.  case unitval11 :
  1005.  case unicon11 :
  1006.  case uninil11 :
  1007.  case putpvar11 :
  1008.  case putpval11 :
  1009.  case puttvar11 :
  1010.  case putcon11 :
  1011.  case putnil11 :
  1012.  case putstr11 :
  1013.  case putlist11 :
  1014.  case bldpvar11 :
  1015.  case bldpval11 :
  1016.  case bldtvar11 :
  1017.  case bldtval11 :
  1018.  case bldcon11 :
  1019.  case bldnil11 :
  1020.  
  1021.  default: 
  1022.     printf("\nIllegal opcode hex %x at %x\n", *--lpcreg, lpcreg); 
  1023.     exit(1);
  1024.  
  1025.  
  1026.   } /* end switch */
  1027.  }  /*  end main instruction loop */
  1028.  
  1029.  
  1030. nunify: /* ( op1, op2 ) */
  1031. /* word op1, op2 */
  1032.   switch ((int) (op1 & 3)) {
  1033.   case FREE: /* op1 */
  1034.     nderef(op1, nunify);
  1035.     nunify_with_free: /* op1 is a dereffed free node */
  1036.         switch ((int) (op2 & 3)) {
  1037.         case FREE:  /* op1 = free var, op2 = free var */
  1038.         nderef(op2,  nunify_with_free);
  1039.         if ( op1 != op2 ) {
  1040.             if ( op1 < op2 ) {
  1041.             if ( op1 < (word)hreg )  /* op1 not in loc stack */
  1042.                 {follow(op2) = op1;
  1043.                  pushtrail(op2);}
  1044.             else  /* op1 points to op2 */
  1045.                 {follow(op1) = op2;
  1046.                  pushtrail(op1);}
  1047.             }
  1048.             else { /* op1 > op2 */
  1049.             if ( op2 < (word)hreg ) 
  1050.                 {follow(op1) = op2;
  1051.                  pushtrail(op1);}
  1052.             else
  1053.                 {follow(op2) = op1;
  1054.                  pushtrail(op2);}
  1055.             }
  1056.         }
  1057.         break; /* op1=free, op2=free */
  1058.         case CS:      /* op1=free, op2=con/str */
  1059.         case LIST:      /* op1=free, op2=list */
  1060.         case NUM:     /* op1=free, op2=num */
  1061.         follow(op1) = op2;
  1062.         pushtrail(op1);
  1063.         break;    /* op1=free, op2=c/s,list,num */
  1064.         }
  1065.     break; /* op1=free */
  1066.  
  1067.   case CS: /* op1=c/s */
  1068.     nu2: switch ((int)(op2 & 3)) {
  1069.     case FREE:  /* op1=con/str, op2=free */
  1070.     nderef(op2, nu2);
  1071.     follow(op2) = op1;
  1072.     pushtrail(op2);
  1073.         break; /* op1=con/str, op2=free */
  1074.     case CS:   /* op1=con/str, op2=con/str */
  1075.         if (op1 != op2) {    /* a != b */
  1076.         untag(op1);
  1077.         untag(op2);
  1078.         if (follow(op1) != follow(op2)) { /* 0(a) != 0(b) */
  1079.         Fail1;
  1080.         break; /* op1=c/s, op2=c/s */
  1081.         }
  1082.         else {
  1083.                arity = get_str_arity(op1);
  1084.                for ( i=1; i <= arity;  i++ ) 
  1085.                  if(!unify(*((pw)op1+i), *((pw)op2+i)))
  1086.             {Fail1; 
  1087.             goto nbreakconcon;} /* break out of BOTH for and case */
  1088.         }
  1089.     }
  1090.         nbreakconcon: break; /* out of con/str, con/str */
  1091.     case LIST:    /* op1 = con/str, op2 = list */
  1092.     case NUM:
  1093.       Fail1;
  1094.       break;
  1095.        /* op1=c/s, op2=list, */
  1096.     } /* end case op1=c/s */
  1097.     break;
  1098.  
  1099.   case LIST:    /* op1=list */
  1100.     nu3: switch ((int)(op2 & 3)) {
  1101.     case FREE:  /* op1=list, op2=free */
  1102.       nderef(op2, nu3);
  1103.       follow(op2) = op1;
  1104.       pushtrail(op2);
  1105.       break; /* op1-list, op2=free */
  1106.     case CS:    /* op1=list, op2=con/str */
  1107.     case NUM:    /* op1=list, op2=num */
  1108.       Fail1;
  1109.       break;    /* op1=list, op2=c/s,num */
  1110.     case LIST:   /* op1=list, op2=list */
  1111.       if (op1 != op2) {
  1112.          untag(op1);
  1113.          untag(op2);
  1114.          if ( !unify(*(pw)op1, *(pw)op2)
  1115.              || !unify( *(((pw)op1)+1), *(((pw)op2)+1) ) )
  1116.         {Fail1; break;}
  1117.      }
  1118.       break; /* op1=list, op2=list */
  1119.     }
  1120.     break; /* op1=list */
  1121.   case NUM:    /* op1=num */
  1122.     nwn: switch ((int)(op2 & 3)) {
  1123.     case FREE:  /* op1=num, op2=free */
  1124.         nderef(op2, nwn);
  1125.         follow(op2) = op1;
  1126.         pushtrail(op2);
  1127.         break; /* op1=num, op2=free */
  1128.         case NUM:   /*op1=num, op2=num */
  1129.         if (op1 == op2) break;        /* op1=num, op2=num */
  1130.         else
  1131.         if ((isfloat(op1) || isfloat(op2)) &&
  1132.             prettymuch_equal((double)numval(op2), (double)numval(op1))) break;
  1133.     case CS:
  1134.     case LIST:
  1135.         Fail1;
  1136.         break; /* op1=num, op2=c/s,list */
  1137.     }    /* disp on op2 */
  1138.   break; /* disp on op1 */
  1139.   }    /* end of disp on op1 */
  1140.   goto contcase;  /* end of nunify */
  1141.  
  1142.  
  1143. nunify_with_con: /* op1,  op2=(untagged)con */
  1144.     switch((int) (op1 & 3)) {
  1145.     case FREE:  /* op2=(untagged)con, op1=free */
  1146.     nderef(op1, nunify_with_con);
  1147.     follow(op1) = op2 | CS_TAG;
  1148.     pushtrail(op1);
  1149.         break; /* op1=free */
  1150.     case CS:   /* op2=(untagged)con, op1=con/str */
  1151.     untag(op1);
  1152.         if (op1 != op2) {    /* a != b */
  1153.         if (follow(op2) != follow(op1))  /* 0(a) != 0(b) */
  1154.         {Fail1;}
  1155.         /* else must be converted temp const and are same */
  1156.     }
  1157.         break; /* out of con/str, con/str */
  1158.     case LIST:    /* op2 = con/str, op1 = list */
  1159.     case NUM:
  1160.       Fail1;
  1161.       break;
  1162.     } /* end case nunify_with_con */
  1163.     goto contcase;
  1164.  
  1165. nunify_with_int: /* op1 is general, op2 has integer (untagged) */
  1166.      switch ((int) (op1 & 3)) {
  1167.     case FREE:  /* op1=free */
  1168.         nderef(op1, nunify_with_int);
  1169.         follow(op1) = makeint(op2);
  1170.         pushtrail(op1);
  1171.         break; /* op2=num, op1=free */
  1172.         case NUM:   /*op2=num, op1=num */
  1173.         if (isinteger(op1) && (intval(op1) == op2)) break;
  1174.         else if (isfloat(op1) && prettymuch_equal((double)numval(op1), (double)op2))
  1175.         break;
  1176.     case CS:
  1177.     case LIST:
  1178.         Fail1;
  1179.         break;
  1180.     }    /* disp on op1 */
  1181.   goto contcase; /* end of nunify_with_int */
  1182.  
  1183. nunify_with_float:  /* op1 is general, op2 is tagged float in WAM format */
  1184.     switch ((int) (op1 & 3)) {
  1185.     case FREE:  /* op1=free */
  1186.         nderef(op1, nunify_with_float);
  1187.         follow(op1) = op2;
  1188.         pushtrail(op1);
  1189.         break;  /* op2 = float, op1 = free */
  1190.     case NUM:
  1191.         if (prettymuch_equal(numval(op1), numval(op2))) break;
  1192.     case CS:
  1193.     case LIST:
  1194.         Fail1;
  1195.         break;
  1196.     }   /* disp on op1 */
  1197.     goto contcase;  /* end of nunify_with_float */
  1198.  
  1199. nunify_with_nil: /* op1, nil_sym(tagged) */
  1200.   switch((int) (op1 & 3)) {
  1201.     case FREE:  /* op1=free */
  1202.     nderef(op1, nunify_with_nil);
  1203.     follow(op1) = nil_sym;
  1204.     pushtrail(op1);
  1205.         break; /* op1=free */
  1206.     case CS:   /* op1=con/str */
  1207.         if (op1 == nil_sym) break;    /* a == [] */
  1208.     case LIST:
  1209.     case NUM:
  1210.       Fail1;
  1211.       break;
  1212.     } /* end case nunify_with_nil */
  1213.     goto contcase;
  1214.  
  1215.  
  1216. nunify_with_str: /* (op1, op2 as psc_ptr) */
  1217.     /* struct psc_rec *str_ptr; using op2 */
  1218.     switch ((int) (op1 & 3)) {
  1219.     case FREE:
  1220.         nderef(op1, nunify_with_str);
  1221.         follow(op1) = (word)hreg | CS_TAG;
  1222.         pushtrail(op1); /**/
  1223.         new_heap_node(op2);
  1224.         flag = WRITEFLAG;
  1225.         break;
  1226.     case CS:
  1227.         untag(op1);
  1228.         if (follow(op1) == op2) {
  1229.         flag = READFLAG;
  1230.         sreg = ((pw) op1) + 1; /**/
  1231.         break;
  1232.         }
  1233.     case LIST:
  1234.     case NUM:
  1235.         Fail1;
  1236.         break;
  1237.     } /* case for nunify_with_str */
  1238.     goto contcase;
  1239.  
  1240. nunify_with_list_sym: /* (op1) */
  1241.     switch ((int) (op1 & 3)) {
  1242.     case FREE:
  1243.         nderef(op1, nunify_with_list_sym);
  1244.         follow(op1) = (word)hreg | LIST_TAG;
  1245.         pushtrail(op1);
  1246.         flag = WRITEFLAG;
  1247.         break;
  1248.     case CS:
  1249.     case NUM:
  1250.         Fail1;
  1251.         break;
  1252.     case LIST:
  1253.         sreg = (pw)(untagged(op1));
  1254.         flag = READFLAG;
  1255.         break;
  1256.     }   /* end nunify_with_list_sym */
  1257.     goto contcase;
  1258.  
  1259.  
  1260. nbldval:
  1261.     if ((op1 & 3) == 0)
  1262.     {nderef(op1, nbldval);
  1263.      follow(op1) = (word)hreg;
  1264.      pushtrail(op1);
  1265.      new_heap_free;}
  1266.     else new_heap_node(op1);
  1267.     goto contcase;
  1268.     
  1269. subtryme:
  1270. {
  1271.   register word *b;
  1272.   if (breg < le_reg)
  1273.     b = breg;
  1274.   else
  1275.     b = le_reg - *(cpreg - 5) ;  /* 1st arg. of call instruction */
  1276.  
  1277.     if (b < hreg+100) if (!overflow_f) 
  1278.         {overflow_f = 1; lpcreg = set_intercode(2); goto contcase;}
  1279.  
  1280.   for (i = 1; i <= op1; i++)
  1281.     {
  1282.     *b-- = regc(i);
  1283.     /* b = b + 1; */
  1284.     }
  1285.   *b-- = (word)le_reg;
  1286.   *b-- = (word)cpreg;
  1287.   *b-- = (word)trreg;
  1288.   *b-- = (word)hreg;
  1289.   *b-- = (word)breg;
  1290.   *b-- = op2;  /* next process' entry pt. */
  1291.   breg = b; /* next free space was b+6*/
  1292.   hbreg = hreg;}
  1293.   goto contcase; /* end of subtryme */
  1294.   
  1295.  
  1296. rerestore:
  1297. {
  1298.   register word *b;
  1299.   word *oldtr;
  1300.  
  1301.   b = breg + 3;
  1302.   hreg = (pw)*(b);
  1303.   oldtr = (pw)*(++b);
  1304.   while (trreg != oldtr)
  1305.     {
  1306.     top = (pw)(*(++trreg));
  1307.     *(pw *)top = top; 
  1308.     }
  1309.   cpreg = (pb)*(++b);
  1310.   le_reg = (pw)(*(++b));
  1311.   for (i = op1; i >= 1;i--) 
  1312.     {
  1313.     regc(i) = *(++b);
  1314.     /* b = b - 1; */
  1315.     }
  1316.   }
  1317.   goto contcase;
  1318.  
  1319.  
  1320. trrestore:
  1321. {
  1322.   register word *b;
  1323.   word *oldtr;
  1324.  
  1325.   b = breg + 3;
  1326.   hreg = (pw)*(b);
  1327.   oldtr = (pw)*(++b);
  1328.   while (trreg != oldtr)
  1329.     {
  1330.     top = (pw)*(++trreg);
  1331.     *(pw *)top = top; 
  1332.     }
  1333.   cpreg = (pb)*(++b);
  1334.   le_reg = (pw)*(++b);
  1335.   for (i = op1; i >= 1;i--) 
  1336.     {
  1337.     regc(i) = *(++b);
  1338.     }
  1339.   }
  1340.   breg = (pw)*(breg + 2);
  1341.   hbreg = (pw)*(breg + 3);
  1342.   goto contcase;
  1343.  
  1344.  
  1345.  
  1346. call_sub: /* (psc)*/
  1347.  
  1348.  
  1349.   if (interrupt_code > 0) { /* combine with call_intercept check! */
  1350.  
  1351.     build_call(psc);
  1352.  
  1353.     lpcreg = set_intercode(1);
  1354.  
  1355.     interrupt_code = 0;
  1356.  
  1357.     arm_intercept();
  1358.  
  1359.     psc = interrupt_psc;
  1360.   }
  1361.   else if (is_PRED(psc) || is_DYNA(psc)) {   
  1362.  
  1363.                     lpcreg = get_ep(psc);
  1364.  
  1365.                     }
  1366.   else if (is_BUFF(psc)) {
  1367.                 lpcreg = (byte *)get_name(psc)+4;
  1368.  
  1369.                  }                 
  1370.   else { 
  1371.  
  1372.     build_call(psc);
  1373.  
  1374.     lpcreg = set_intercode(0);
  1375.  
  1376.     psc = interrupt_psc;
  1377.  
  1378.   }
  1379.  
  1380.   if (call_intercept) {
  1381.       if (hitrace) {
  1382.  
  1383.          writepname(stdout, get_name(psc), get_length(psc) );
  1384.          printf("/%d(", get_arity(psc));
  1385.          for (i=1; i <= get_arity(psc); i++) {
  1386.             printterm( regc(i), 1 );
  1387.             if (i < get_arity(psc)) printf(" ");
  1388.          }
  1389.          printf(")\n");
  1390.       }
  1391.       if (trace_sta) {
  1392.     if (hreg > mheaptop) mheaptop = hreg;
  1393.     if (ereg < mlocaltop) mlocaltop = ereg;
  1394.     if (breg < mlocaltop) mlocaltop = breg;
  1395.         if (trreg < mtrailtop) mtrailtop = trreg;
  1396.       }
  1397.   }
  1398.  
  1399.   goto contcase;
  1400.  
  1401.  
  1402. } /* end main */
  1403.  
  1404.